home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / programm.ing / gfa / progpk10.lzh / PROGPK10.LST < prev    next >
Encoding:
File List  |  1992-09-03  |  8.8 KB  |  396 lines
  1. ' ******************************************************************************
  2. ' ***********       Programmers Pak v1.0 by Harry Sarber        ****************
  3. ' *********************     Started:  02/28/1992    ****************************
  4. ' ******************************************************************************
  5. '
  6. $m4096
  7. '
  8. start
  9. '
  10. ' *** Setup for Accessory or Program ***
  11. PROCEDURE start
  12.   v_rez&=CARD{L~A-4}
  13.   h_rez&=CARD{L~A-12}
  14.   IF v_rez&>200
  15.     xf=1
  16.     yf%=2
  17.     rez%=2
  18.     rsrc$="PROGPKHI.RSC"
  19.     tx%=27
  20.     ty%=5
  21.   ELSE
  22.     xf=1
  23.     yf%=1
  24.     rez%=1
  25.     rsrc$="PROGPK10.RSC"
  26.     tx%=27
  27.     ty%=5
  28.   ENDIF
  29.   IF h_rez&<=320
  30.     xf=0.5
  31.     rez%=0
  32.     tx%=7
  33.     ty%=5
  34.   ELSE
  35.     xf=1
  36.   ENDIF
  37.   ap_id&=APPL_INIT()
  38.   IF ap_id&
  39.     me_id&=MENU_REGISTER(ap_id&,"  Prog Pak v1.0")
  40.     IF EXIST(rsrc$)
  41.       init
  42.       DO
  43.         ~EVNT_MESAG(0)
  44.         IF MENU(1)=40
  45.           doit
  46.           gone
  47.         ENDIF
  48.       LOOP
  49.     ELSE
  50.       rsc_missing
  51.     ENDIF
  52.   ELSE
  53.     IF EXIST(rsrc$)
  54.       init
  55.       doit
  56.       gone
  57.     ELSE
  58.       rsc_missing
  59.     ENDIF
  60.   ENDIF
  61. RETURN
  62. ' *** Initialize ***
  63. PROCEDURE init
  64.   ON ERROR GOSUB error
  65.   ON BREAK CONT
  66.   last_rev_date$="09/02/92"
  67.   version$="1.0"
  68.   ' Credits
  69.   PRINT AT(tx%,ty%);CHR$(27)+"p* * * * * * * * * * * * *"
  70.   PRINT AT(tx%,ty%+1);"* Programmers Pak v";version$;"  *"
  71.   PRINT AT(tx%,ty%+2);"*    by Harry Sarber    *"
  72.   PRINT AT(tx%,ty%+3);"*       ";last_rev_date$;"        *"
  73.   PRINT AT(tx%,ty%+4);"* * * * * * * * * * * * *"
  74.   PRINT CHR$(27)+"q"
  75.   PAUSE 100
  76.   DEFMOUSE 0
  77.   ' Set resource constants
  78.   LET progpak&=0 !RSC_TREE
  79.   LET ascii&=3 !Obj in #0
  80.   LET keycodes&=4 !Obj in #0
  81.   LET patterns&=5 !Obj in #0
  82.   LET textstyl&=6 !Obj in #0
  83.   LET linestyl&=7 !Obj in #0
  84.   LET markers&=8 !Obj in #0
  85.   LET exitpak&=10 !Obj in #0
  86.   ' Load resource file
  87.   ~RSRC_FREE()
  88.   ~RSRC_LOAD(rsrc$)
  89.   ~RSRC_GADDR(0,progpak&,tree_add1%)
  90.   ' Pattern array
  91.   DIM patterns(36,2)
  92.   FOR i%=0 TO 23
  93.     IF i%<12
  94.       patterns(i%+24,0)=3
  95.       patterns(i%+24,1)=i%+1
  96.     ENDIF
  97.     patterns(i%,0)=2
  98.     patterns(i%,1)=i%+1
  99.   NEXT i%
  100.   ' Text size array
  101.   DIM textsizes(6)
  102.   RESTORE textsizes
  103.   FOR i%=0 TO 5
  104.     READ textsizes(i%)
  105.   NEXT i%
  106. textsizes:
  107.   DATA 6,10,12,18,24,32
  108.   ' Marker array
  109.   DIM x%(1)
  110.   DIM y%(1)
  111.   ' ASCII codes array
  112.   DIM concodes$(33)
  113.   RESTORE concodes
  114.   FOR i%=0 TO 32
  115.     READ concodes$(i%)
  116.   NEXT i%
  117. concodes:
  118.   DATA NUL,none,none,none,none,none,none,BELL,BS,HT,LF,VT,FF,CR,SO,SI,none
  119.   DATA DC1,DC2,DC3,DC4,none,none,none,CAN,EM,none,ESC,none,none,none,none,SPACE
  120. RETURN
  121. ' *** Main Routine ***
  122. PROCEDURE doit
  123.   HIDEM
  124.   TITLEW #1," Programmers Pak v"+version$+" "
  125.   OPENW #1,0,11*yf%,h_rez&-1,188*yf%,1
  126.   DEFTEXT 1,0,,6
  127.   CLEARW #1
  128. restart:
  129.   REPEAT
  130.     CLEARW #1
  131.     DEFMOUSE 0
  132.     ~FORM_CENTER(tree_add1%,x%,y%,w%,h%)
  133.     ~OBJC_DRAW(tree_add1%,0,5,x%,y%,w%,h%)
  134.     SHOWM
  135.     REPEAT
  136.     UNTIL MOUSEK=0
  137.     pp%=FORM_DO(tree_add1%,0)
  138.     IF pp%=patterns&
  139.       @patterns
  140.     ELSE IF pp%=textstyl&
  141.       @textstyles
  142.     ELSE IF pp%=linestyl&
  143.       @linestyles
  144.     ELSE IF pp%=markers&
  145.       @markers
  146.     ELSE IF pp%=keycodes&
  147.       @keycodes
  148.     ELSE IF pp%=ascii&
  149.       @ascii
  150.     ENDIF
  151.     TITLEW #1," Programmers Pak v"+version$+" "
  152.     ~OBJC_CHANGE(tree_add1%,pp%,0,x%,y%,w%,h%,0,0)
  153.   UNTIL pp%=exitpak&
  154.   ~OBJC_CHANGE(tree_add1%,pp%,0,x%,y%,w%,h%,0,0)
  155. RETURN
  156. ' *** Exit Program ***
  157. PROCEDURE gone
  158.   CLEARW #1
  159.   CLOSEW #1
  160.   ~RSRC_FREE()
  161. RETURN
  162. ' *** Patterns Utility ***
  163. PROCEDURE patterns
  164.   CLEARW #1
  165.   TITLEW #1," Patterns "
  166.   DEFLINE 1,1,0,0
  167.   HIDEM
  168.   p1=2
  169.   p2=1
  170.   FOR y=1 TO 6
  171.     FOR x=1 TO 6
  172.       xpos=(x-1)*106
  173.       ypos=(y-1)*24
  174.       RBOX (xpos+4)*xf,(ypos+2)*yf%,(xpos+98)*xf,(ypos+14)*yf%
  175.       DEFFILL 1,p1,p2
  176.       FILL (xpos+10)*xf,(ypos+10)*yf%
  177.       PRINT AT(((xpos*xf)/8)+(6*xf),(((ypos)/8)+3)*yf%);p1;",";p2;
  178.       p2=p2+1
  179.       IF p2=25
  180.         p1=3
  181.         p2=1
  182.       ENDIF
  183.     NEXT x
  184.   NEXT y
  185.   PRINT
  186.   PRINT
  187.   PRINT "Press right button or any key...";
  188.   wait
  189.   TITLEW #1," Programmers Pak "
  190.   SHOWM
  191. RETURN
  192. ' *** Text styles and sizes Utility ***
  193. PROCEDURE textstyles
  194.   CLEARW #1
  195.   TITLEW #1," Text Styles "
  196.   DEFTEXT 1,0,,6
  197.   TEXT 2*xf,20*yf%,"Style"+CHR$(3)
  198.   TEXT 2*xf,30*yf%,"Height"
  199.   TEXT 108*xf,20*yf%,"0"
  200.   TEXT 40*xf,40*yf%,"6"
  201.   IF rez%=0
  202.     TEXT 108*xf,40*yf%,"A"
  203.   ELSE
  204.     TEXT 108*xf,40*yf%,"ABC"
  205.   ENDIF
  206.   DEFTEXT 1,0,,13
  207.   TEXT 34*xf,60*yf%,"13"
  208.   IF rez%=0
  209.     TEXT 108*xf,60*yf%,"A"
  210.   ELSE
  211.     TEXT 108*xf,60*yf%,"ABC"
  212.   ENDIF
  213.   DEFTEXT 1,0,,32
  214.   TEXT 26*xf,90*yf%,"32"
  215.   IF rez%=0
  216.     TEXT 108*xf,90*yf%,"A"
  217.   ELSE
  218.     TEXT 108*xf,90*yf%,"ABC"
  219.   ENDIF
  220.   DEFTEXT 1,0,,6
  221.   FOR i%=0 TO 5
  222.     DEFTEXT 1,0,,6
  223.     TEXT (i%*70+176)*xf,20*yf%,STR$(2^i%)
  224.     DEFTEXT 1,2^i%,,6
  225.     IF rez%=0
  226.       TEXT (i%*70+186)*xf,40*yf%,"A"
  227.     ELSE
  228.       TEXT (i%*70+186)*xf,40*yf%,"ABC"
  229.     ENDIF
  230.     DEFTEXT 1,2^i%,,13
  231.     IF rez%=0
  232.       TEXT (i%*70+186)*xf,60*yf%,"A"
  233.     ELSE
  234.       TEXT (i%*70+186)*xf,60*yf%,"ABC"
  235.     ENDIF
  236.     DEFTEXT 1,2^i%,,32
  237.     IF rez%=0
  238.       TEXT (i%*70+186)*xf,90*yf%,"A"
  239.     ELSE
  240.       TEXT (i%*70+186)*xf,90*yf%,"ABC"
  241.     ENDIF
  242.   NEXT i%
  243.   DEFTEXT 1,0,,6
  244.   TEXT 20*xf,130*yf%,"Press right button or any key..."
  245.   wait
  246. RETURN
  247. ' *** Line styles utility ***
  248. PROCEDURE linestyles
  249.   CLEARW #1
  250.   TITLEW #1," Line Styles "
  251.   DEFTEXT 1,0,,6
  252.   TEXT 20*xf,10*yf%,"Styles"
  253.   FOR e=1 TO 6
  254.     DEFLINE e,,0,0
  255.     TEXT 40,((e-1)*26+19)*yf%,STR$(e)
  256.     LINE 100*xf,((e-1)*26+17)*yf%,250*xf,((e-1)*26+17)*yf%
  257.   NEXT e
  258.   TEXT 270*xf,10*yf%,"Widths"
  259.   DEFLINE 1,1,1,2
  260.   FOR e=1 TO 11 STEP 2
  261.     DEFLINE ,e
  262.     TEXT 290*xf,(e*13+6)*yf%,STR$(e)
  263.     LINE 350*xf,(e*13+4)*yf%,500*xf,(e*13+4)*yf%
  264.   NEXT e
  265.   TEXT 20*xf,170*yf%,"Press right button or any key..."
  266.   wait
  267.   DEFLINE 1,1,0,0
  268. RETURN
  269. ' *** Markers ***
  270. PROCEDURE markers
  271.   CLEARW #1
  272.   TITLEW #1," Markers "
  273.   DEFTEXT 1,0,,6
  274.   TEXT 20*xf,14*yf%,"Style "+CHR$(3)
  275.   x%(0)=0
  276.   y%(0)=0
  277.   FOR i%=1 TO 6
  278.     TEXT (i%*80+96)*xf,14*yf%,STR$(i%)
  279.     FOR j%=1 TO 12
  280.       DEFMARK 1,i%,j%
  281.       POLYMARK 1,x%(),y%() OFFSET (i%*80+100)*xf,(j%*10+24)*yf%
  282.     NEXT j%
  283.   NEXT i%
  284.   TEXT 20*xf,170*yf%,"Press right button or any key..."
  285.   wait
  286. RETURN
  287. ' *** Key Codes Utility ***
  288. PROCEDURE keycodes
  289.   LOCAL bt,a$
  290.   exit_keycodes!=FALSE
  291.   CLEARW #1
  292.   title$=" 8/16 bit Key Scan codes "
  293.   TITLEW #1,title$
  294.   HIDEM
  295.   PRINT AT(1,1)
  296.   PRINT " Press any key to find the Key Code"
  297.   PRINT "       Press Escape to Exit"
  298.   d=0
  299.   REPEAT
  300.     event=EVNT_MULTI(&X110001,d,d,d,d,d,d,d,d,d,d,d,d,d,adr_mes%,2000,d,d,d,keystate,keycode,d)
  301.     '
  302.     IF (event AND &X1)            ! MU_KEYBD
  303.       code=(keycode AND 255)
  304.       CLEARW #1
  305.       PRINT AT(1,1)
  306.       IF code<>27
  307.         PRINT AT(2,5);" KEY IS :                      "+CHR$(code)
  308.       ELSE
  309.         PRINT AT(2,5);" KEY IS :                      "
  310.       ENDIF
  311.       PRINT AT(2,7);" 16 bit Key Scan code is :     "+STR$(keycode)+"    "
  312.       PRINT AT(2,8);"  8 bit Key Scan code is :     "+STR$(code)+"  "
  313.       PRINT AT(2,9);" Contrl/Shift/Alt key status : "+STR$(keystate)+"  "
  314.       PRINT AT(2,11);" Press any key to find the Key Code"
  315.       PRINT AT(2,12);"        Press Escape to Exit"
  316.       IF code=27
  317.         PRINT
  318.         PRINT "  Pausing for a second......."
  319.         PAUSE 50
  320.         exit_keycodes!=TRUE
  321.       ENDIF
  322.     ENDIF
  323.   UNTIL exit_keycodes!
  324.   SHOWM
  325. RETURN
  326. ' *** ASCII Codes Utility ***
  327. PROCEDURE ascii
  328.   TITLEW #1," ASCII Character Codes "
  329.   CLEARW #1
  330.   HIDEM
  331.   IF rez%=0
  332.     loop1%=3
  333.     loop2%=64
  334.   ELSE
  335.     loop1%=1
  336.     loop2%=128
  337.   ENDIF
  338.   FOR l%=0 TO loop1%
  339.     j%=0
  340.     k%=2
  341.     FOR i%=0 TO loop2%-1
  342.       i$=STR$(i%+(l%*loop2%))
  343.       i$=SPACE$(3-LEN(i$))+i$
  344.       IF l%=0 AND i%<33
  345.         PRINT AT(k%,(j%+3)*yf%);i$;" ";concodes$(i%)
  346.       ELSE
  347.         PRINT AT(k%,(j%+3)*yf%);i$;" ";CHR$(i%+(l%*loop2%))
  348.       ENDIF
  349.       INC j%
  350.       IF j%>16
  351.         j%=0
  352.         ADD k%,10
  353.       ENDIF
  354.     NEXT i%
  355.     DEFTEXT 1,,,6
  356.     TEXT 20*xf,170*yf%,"Press right button or any key..."
  357.     wait
  358.     CLEARW #1
  359.   NEXT l%
  360.   SHOWM
  361. RETURN
  362. ' *** Miscellaneous Subroutines ***
  363. PROCEDURE rsc_missing
  364.   bell
  365.   ALERT 3,rsrc$+" must be in the|same path as PROGPK10.PRG!",1,"Ok",void%
  366. RETURN
  367. PROCEDURE bell
  368.   PRINT AT(1,1);CHR$(7)
  369. RETURN
  370. PROCEDURE error
  371.   bell
  372.   IF FATAL
  373.     CLOSE
  374.     alert$="ERROR # "+STR$(ERR)+"|  |FATAL Error|"
  375.     ALERT 1,alert$,1,"  QUIT  ",void%
  376.     gone
  377.     END
  378.   ELSE
  379.     CLOSE
  380.     alert$="ERROR # "+STR$(ERR)
  381.     ALERT 1,alert$,1,"Restart|Exit",answer%
  382.     IF answer%=2
  383.       gone
  384.       END
  385.     ENDIF
  386.     ON ERROR GOSUB error
  387.     RESUME restart
  388.   ENDIF
  389. RETURN
  390. PROCEDURE wait
  391.   REPEAT
  392.   UNTIL MOUSEK=2 OR INKEY$<>""
  393.   REPEAT
  394.   UNTIL MOUSEK=0 AND INKEY$=""
  395. RETURN
  396.